home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / Caml Light 0.61 / Source / src / linker / symtable.ml < prev    next >
Encoding:
Text File  |  1993-09-24  |  4.6 KB  |  175 lines  |  [TEXT/MPS ]
  1. #open "misc";;
  2. #open "const";;
  3. #open "predef";;
  4.  
  5. (* symtable.ml : to assign numbers to global variables and so on *)
  6.  
  7. let object_name = ref "";;
  8.  
  9. (* Hashtables for numbering objects *)
  10.  
  11. type 'a numtable =
  12.   { mutable num_cnt: int;                   (* The current number *)
  13.     mutable num_tbl: ('a, int) hashtbl__t } (* The table *)
  14. ;;
  15.  
  16. let new_numtable size =
  17.   { num_cnt = 0; num_tbl = hashtbl__new size }
  18. ;;
  19.  
  20. let find_in_numtable nt =
  21.   hashtbl__find nt.num_tbl
  22.  
  23. and enter_in_numtable nt key =
  24.   let c = nt.num_cnt in
  25.     nt.num_cnt <- succ nt.num_cnt;
  26.     hashtbl__add nt.num_tbl key c;
  27.     c
  28.  
  29. and remove_from_numtable nt key =
  30.   hashtbl__remove nt.num_tbl key
  31. ;;
  32.  
  33. (* Global variables *)
  34.  
  35. let global_table =
  36.   ref (new_numtable 1 : qualified_ident numtable)
  37. and literal_table =
  38.   ref ([] : (int * struct_constant) list)
  39. ;;
  40.  
  41. let get_slot_for_variable qualid =
  42.   try
  43.     find_in_numtable !global_table qualid
  44.   with Not_found ->
  45.     prerr_begline ">> ";
  46.     prerr_string qualid.qual; prerr_string "__"; prerr_string qualid.id;
  47.     prerr_string " is referenced";
  48.     if string_length !object_name == 0
  49.     then ()
  50.     else prerr_string (" from " ^ !object_name);
  51.     prerr_endline " before being defined.";
  52.     raise Toplevel
  53. and get_slot_for_defined_variable qualid =
  54.   if !toplevel then
  55.     add_rollback (fun () -> remove_from_numtable !global_table qualid);
  56.   enter_in_numtable !global_table qualid
  57. and get_slot_for_literal cst =
  58.   let c = (!global_table).num_cnt in
  59.     (!global_table).num_cnt <- succ (!global_table).num_cnt;
  60.     literal_table := (c, cst) :: !literal_table;
  61.     c
  62. and number_of_globals () =
  63.   (!global_table).num_cnt
  64. ;;
  65.  
  66. (* The exception tags *)
  67.  
  68. let exn_tag_table = ref(new_numtable 1 : (qualified_ident * int) numtable)
  69. and tag_exn_table = ref( [| |] : (qualified_ident * int) vect )
  70. and unknown_exn_name = ({qual="?"; id="?"}, 0)
  71. ;;
  72.  
  73. let get_num_of_exn (name, stamp) =
  74.   try
  75.     hashtbl__find (!exn_tag_table).num_tbl (name, stamp)
  76.   with Not_found ->
  77.     let c = enter_in_numtable !exn_tag_table (name, stamp) in
  78.       if c >= vect_length !tag_exn_table then begin
  79.         let new_tag_exn_table =
  80.           make_vect (2 * vect_length !tag_exn_table) unknown_exn_name
  81.         in
  82.           blit_vect !tag_exn_table 0
  83.                     new_tag_exn_table 0
  84.                     (vect_length !tag_exn_table - 1);
  85.           tag_exn_table := new_tag_exn_table
  86.       end;
  87.       (!tag_exn_table).(c) <- (name, stamp);
  88.       c
  89. ;;
  90.  
  91. let get_exn_of_num tag =
  92.   if tag >= vect_length !tag_exn_table
  93.   then unknown_exn_name
  94.   else (!tag_exn_table).(tag)
  95. ;;
  96.  
  97. let get_num_of_tag = function
  98.     ConstrRegular(n,_) -> n
  99.   | ConstrExtensible(id, stamp) -> get_num_of_exn(id, stamp)
  100. ;;
  101.  
  102. (* The C primitives *)
  103.  
  104. let custom_runtime = ref false
  105. ;;
  106. let c_prim_table = ref (new_numtable 0 : string numtable)
  107. ;;
  108.  
  109. let set_c_primitives prim_vect =
  110.   c_prim_table := new_numtable 31;
  111.   do_vect (enter_in_numtable !c_prim_table) prim_vect
  112. ;;
  113.  
  114. let get_num_of_prim name =
  115.   try
  116.     find_in_numtable !c_prim_table name
  117.   with Not_found ->
  118.     if !custom_runtime then
  119.       enter_in_numtable !c_prim_table name
  120.     else begin
  121.       prerr_begline ">> Unavailable C primitive ";
  122.       prerr_endline name;
  123.       raise Toplevel
  124.     end
  125. ;;
  126.  
  127. let output_primitives oc =
  128.   let prim = make_vect (!c_prim_table).num_cnt "" in
  129.     hashtbl__do_table
  130.       (fun name number -> prim.(number) <- name)
  131.       (!c_prim_table).num_tbl;
  132.     for i = 0 to vect_length prim - 1 do
  133.       output_string oc ("extern long " ^ prim.(i) ^ "();\n")
  134.     done;
  135.     output_string oc "typedef long (*primitive)();\n";
  136.     output_string oc "primitive cprim[] = {\n";
  137.     for i = 0 to vect_length prim - 1 do
  138.       output_string oc ("  " ^ prim.(i) ^ ",\n")
  139.     done;
  140.     output_string oc "  0 };\n";
  141.     output_string oc "char * names_of_cprim[] = {\n";
  142.     for i = 0 to vect_length prim - 1 do
  143.       output_string oc ("  \"" ^ prim.(i) ^ "\",\n")
  144.     done;
  145.     output_string oc "  (char *) 0 };\n"
  146. ;;
  147.  
  148. (* Initialization *)
  149.  
  150. let reset_linker_tables () =
  151.   global_table := new_numtable 263;
  152.   literal_table := [];
  153.   do_list get_slot_for_defined_variable predef_variables;
  154.   exn_tag_table := new_numtable 31;
  155.   tag_exn_table := make_vect 50 unknown_exn_name;
  156.   do_list get_num_of_exn predef_exn;
  157.   set_c_primitives prim_c__primitives_table
  158. ;;
  159.  
  160.  
  161. (* To write and read linker tables to a file *)
  162.  
  163. let save_linker_tables outstream =
  164.   output_value outstream !global_table;
  165.   output_value outstream !exn_tag_table;
  166.   output_value outstream !tag_exn_table
  167.  
  168. and load_linker_tables instream =
  169.   global_table := input_value instream;
  170.   exn_tag_table := input_value instream;
  171.   tag_exn_table := input_value instream;
  172.   ()
  173. ;;
  174.  
  175.